home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / bind.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  18.5 KB  |  872 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     bind.c
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. struct nil3 { object nil3_self[3]; } three_nils;
  14. struct nil6 { object nil6_self[6]; } six_nils;
  15.  
  16. struct required {
  17.     object    req_var;
  18.     object    req_spp;
  19. };
  20.  
  21. struct optional {
  22.     object    opt_var;
  23.     object    opt_spp;
  24.     object    opt_init;
  25.     object    opt_svar;
  26.     object    opt_svar_spp;
  27. };
  28.  
  29. struct rest {
  30.     object    rest_var;
  31.     object    rest_spp;
  32. };
  33.  
  34. struct keyword {
  35.     object    key_word;
  36.     object    key_var;
  37.     object    key_spp;
  38.     object    key_init;
  39.     object    key_svar;
  40.     object    key_svar_spp;
  41.     object    key_val;
  42.     object    key_svar_val;
  43. };
  44.  
  45. struct aux {
  46.     object    aux_var;
  47.     object    aux_spp;
  48.     object    aux_init;
  49. };
  50.  
  51. object ANDoptional;
  52. object ANDrest;
  53. object ANDkey;
  54. object ANDallow_other_keys;
  55. object ANDaux;
  56.  
  57. object Kallow_other_keys;
  58.  
  59. static object temporary;
  60.  
  61. #define    isdeclare(x)    ((x) == Sdeclare)
  62.  
  63. lambda_bind(arg_top)
  64. object *arg_top;
  65. {
  66.     object lambda, lambda_list, body, form, x, ds, vs, v;
  67.     int narg, i, j;
  68.     object *base = vs_base;
  69.     struct required *required;
  70.     int nreq;
  71.     struct optional *optional;
  72.     int nopt;
  73.     struct rest *rest;
  74.     bool rest_flag;
  75.     struct keyword *keyword;
  76.     bool key_flag;
  77.     bool allow_other_keys_flag, other_keys_appeared;
  78.     int nkey;
  79.     struct aux *aux;
  80.     int naux;
  81.     bool special_processed;
  82.     vs_mark;
  83.  
  84.     bds_check;
  85.     lambda = vs_head;
  86.     if (type_of(lambda) != t_cons)
  87.         FEerror("No lambda list.", 0);
  88.     lambda_list = lambda->c.c_car;
  89.     body = lambda->c.c_cdr;
  90.  
  91.     required = (struct required *)vs_top;
  92.     nreq = 0;
  93.     for (;;) {
  94.         if (endp(lambda_list))
  95.             goto REQUIRED_ONLY;
  96.         x = lambda_list->c.c_car;
  97.         lambda_list = lambda_list->c.c_cdr;
  98.         check_symbol(x);
  99.         if (x == ANDallow_other_keys)
  100.             illegal_lambda();
  101.         if (x == ANDoptional) {
  102.             nopt = nkey = naux = 0;
  103.             rest_flag = key_flag = allow_other_keys_flag
  104.             = FALSE;
  105.             goto OPTIONAL;
  106.         }
  107.         if (x == ANDrest) {
  108.             nopt = nkey = naux = 0;
  109.             key_flag = allow_other_keys_flag
  110.             = FALSE;
  111.             goto REST;
  112.         }
  113.         if (x == ANDkey) {
  114.             nopt = nkey = naux = 0;
  115.             rest_flag = allow_other_keys_flag
  116.             = FALSE;
  117.             goto KEYWORD;
  118.         }
  119.         if (x == ANDaux) {
  120.             nopt = nkey = naux = 0;
  121.             rest_flag = key_flag = allow_other_keys_flag
  122.             = FALSE;
  123.             goto AUX;
  124.         }
  125.         if ((enum stype)x->s.s_stype == stp_constant)
  126.             FEerror("~S is not a variable.", 1, x);
  127.         vs_push(x);
  128.         vs_push(Cnil);
  129.         nreq++;
  130.     }
  131.  
  132. OPTIONAL:
  133.     optional = (struct optional *)vs_top;
  134.     for (;;  nopt++) {
  135.         if (endp(lambda_list))
  136.             goto SEARCH_DECLARE;
  137.         x = lambda_list->c.c_car;
  138.         lambda_list = lambda_list->c.c_cdr;
  139.         if (type_of(x) == t_cons) {
  140.             check_symbol(x->c.c_car);
  141.             check_var(x->c.c_car);
  142.             vs_push(x->c.c_car);
  143.             x = x->c.c_cdr;
  144.             vs_push(Cnil);
  145.             if (endp(x)) {
  146.                 *(struct nil3 *)vs_top = three_nils;
  147.                 vs_top += 3;
  148.                 continue;
  149.             }
  150.             vs_push(x->c.c_car);
  151.             x = x->c.c_cdr;
  152.             if (endp(x)) {
  153.                 vs_push(Cnil);
  154.                 vs_push(Cnil);
  155.                 continue;
  156.             }
  157.             check_symbol(x->c.c_car);
  158.             check_var(x->c.c_car);
  159.             vs_push(x->c.c_car);
  160.             vs_push(Cnil);
  161.             if (!endp(x->c.c_cdr))
  162.                 illegal_lambda();
  163.         } else {
  164.             check_symbol(x);
  165.             if (x == ANDoptional ||
  166.                 x == ANDallow_other_keys)
  167.                 illegal_lambda();
  168.             if (x == ANDrest)
  169.                 goto REST;
  170.             if (x == ANDkey)
  171.                 goto KEYWORD;
  172.             if (x == ANDaux)
  173.                 goto AUX;
  174.             check_var(x);
  175.             vs_push(x);
  176.             *(struct nil6 *)vs_top = six_nils;
  177.             vs_top += 4;
  178.         }
  179.     }
  180.  
  181. REST:
  182.     rest = (struct rest *)vs_top;
  183.     if (endp(lambda_list))
  184.         illegal_lambda();
  185.     check_symbol(lambda_list->c.c_car);
  186.     check_var(lambda_list->c.c_car);
  187.     rest_flag = TRUE;
  188.     vs_push(lambda_list->c.c_car);
  189.     vs_push(Cnil);
  190.     lambda_list = lambda_list->c.c_cdr;
  191.     if (endp(lambda_list))
  192.         goto SEARCH_DECLARE;
  193.     x = lambda_list->c.c_car;
  194.     lambda_list = lambda_list->c.c_cdr;
  195.     check_symbol(x);
  196.     if (x == ANDoptional || x == ANDrest ||
  197.         x == ANDallow_other_keys)
  198.         illegal_lambda();
  199.     if (x == ANDkey)
  200.         goto KEYWORD;
  201.     if (x == ANDaux)
  202.         goto AUX;
  203.     illegal_lambda();
  204.  
  205. KEYWORD:
  206.     keyword = (struct keyword *)vs_top;
  207.     key_flag = TRUE;
  208.     for (;;  nkey++) {
  209.         if (endp(lambda_list))
  210.             goto SEARCH_DECLARE;
  211.         x = lambda_list->c.c_car;
  212.         lambda_list = lambda_list->c.c_cdr;
  213.         if (type_of(x) == t_cons) {
  214.             if (type_of(x->c.c_car) == t_cons) {
  215.                 if (!keywordp(x->c.c_car->c.c_car))
  216.                     FEerror("~S is not a keyword.",
  217.                         1, x->c.c_car->c.c_car);
  218.                 vs_push(x->c.c_car->c.c_car);
  219.                 if (endp(x->c.c_car->c.c_cdr))
  220.                     illegal_lambda();
  221.                 check_symbol(x->c.c_car
  222.                           ->c.c_cdr->c.c_car);
  223.                 vs_push(x->c.c_car->c.c_cdr->c.c_car);
  224.                 if (!endp(x->c.c_car->c.c_cdr->c.c_cdr))
  225.                     illegal_lambda();
  226.             } else {
  227.                 check_symbol(x->c.c_car);
  228.                 check_var(x->c.c_car);
  229.                 vs_push(intern(x->c.c_car, keyword_package));
  230.                 vs_push(x->c.c_car);
  231.             }
  232.             vs_push(Cnil);
  233.             x = x->c.c_cdr;
  234.             if (endp(x)) {
  235.                 *(struct nil6 *)vs_top = six_nils;
  236.                 vs_top += 5;
  237.                 continue;
  238.             }
  239.             vs_push(x->c.c_car);
  240.             x = x->c.c_cdr;
  241.             if (endp(x)) {
  242.                 *(struct nil6 *)vs_top = six_nils;
  243.                 vs_top += 4;
  244.                 continue;
  245.             }
  246.             check_symbol(x->c.c_car);
  247.             check_var(x->c.c_car);
  248.             vs_push(x->c.c_car);
  249.             vs_push(Cnil);
  250.             if (!endp(x->c.c_cdr))
  251.                 illegal_lambda();
  252.             vs_push(Cnil);
  253.             vs_push(Cnil);
  254.         } else {
  255.             check_symbol(x);
  256.             if (x == ANDallow_other_keys) {
  257.                 allow_other_keys_flag = TRUE;
  258.                 if (endp(lambda_list))
  259.                     goto SEARCH_DECLARE;
  260.                 x = lambda_list->c.c_car;
  261.                 lambda_list = lambda_list->c.c_cdr;
  262.             }
  263.             if (x == ANDoptional || x == ANDrest ||
  264.                 x == ANDkey || x == ANDallow_other_keys)
  265.                 illegal_lambda();
  266.             if (x == ANDaux)
  267.                 goto AUX;
  268.             check_var(x);
  269.             vs_push(intern(x, keyword_package));
  270.             vs_push(x);
  271.             *(struct nil6 *)vs_top = six_nils;
  272.             vs_top += 6;
  273.         }
  274.     }
  275.  
  276. AUX:
  277.     aux = (struct aux *)vs_top;
  278.     for (;;  naux++) {
  279.         if (endp(lambda_list))
  280.             goto SEARCH_DECLARE;
  281.         x = lambda_list->c.c_car;
  282.         lambda_list = lambda_list->c.c_cdr;
  283.         if (type_of(x) == t_cons) {
  284.             check_symbol(x->c.c_car);
  285.             check_var(x->c.c_car);
  286.             vs_push(x->c.c_car);
  287.             vs_push(Cnil);
  288.             x = x->c.c_cdr;
  289.             if (endp(x)) {
  290.                 vs_push(Cnil);
  291.                 continue;
  292.             }
  293.             vs_push(x->c.c_car);
  294.             if (!endp(x->c.c_cdr))
  295.                 illegal_lambda();
  296.         } else {
  297.             check_symbol(x);
  298.             if (x == ANDoptional || x == ANDrest ||
  299.                 x == ANDkey || x == ANDallow_other_keys ||
  300.                     x == ANDaux)
  301.                 illegal_lambda();
  302.             check_var(x);
  303.             vs_push(x);
  304.             vs_push(Cnil);
  305.             vs_push(Cnil);
  306.         }
  307.     }
  308.  
  309. SEARCH_DECLARE:
  310.     vs_push(Cnil);
  311.     for (;  !endp(body);  body = body->c.c_cdr) {
  312.         form = body->c.c_car;
  313.  
  314.         /*  MACRO EXPANSION  */
  315.         form = macro_expand(form);
  316.         vs_head = form;
  317.  
  318.         if (type_of(form) == t_string) {
  319.             if (endp(body->c.c_cdr))
  320.                 break;
  321.             continue;
  322.         }
  323.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  324.             break;
  325.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  326.             if (type_of(ds->c.c_car) != t_cons)
  327.                 illegal_declare(form);
  328.             if (ds->c.c_car->c.c_car == Sspecial) {
  329.                 vs = ds->c.c_car->c.c_cdr;
  330.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  331.                     v = vs->c.c_car;
  332.                     check_symbol(v);
  333. /**/
  334.  
  335.     special_processed = FALSE;
  336.     for (i = 0;  i < nreq;  i++)
  337.         if (required[i].req_var == v) {
  338.             required[i].req_spp = Ct;
  339.             special_processed = TRUE;
  340.         }
  341.     for (i = 0;  i < nopt;  i++)
  342.         if (optional[i].opt_var == v) {
  343.             optional[i].opt_spp = Ct;
  344.             special_processed = TRUE;
  345.         } else if (optional[i].opt_svar == v) {
  346.             optional[i].opt_svar_spp = Ct;
  347.             special_processed = TRUE;
  348.         }
  349.     if (rest_flag && rest->rest_var == v) {
  350.         rest->rest_spp = Ct;
  351.         special_processed = TRUE;
  352.     }
  353.     for (i = 0;  i < nkey;  i++)
  354.         if (keyword[i].key_var == v) {
  355.             keyword[i].key_spp = Ct;
  356.             special_processed = TRUE;
  357.         } else if (keyword[i].key_svar == v) {
  358.             keyword[i].key_svar_spp = Ct;
  359.             special_processed = TRUE;
  360.         }
  361.     for (i = 0;  i < naux;  i++)
  362.         if (aux[i].aux_var == v) {
  363.             aux[i].aux_spp = Ct;
  364.             special_processed = TRUE;
  365.         }
  366.     if (special_processed)
  367.         continue;
  368.     /*  lex_special_bind(v);  */
  369.     temporary = MMcons(v, Cnil);
  370.     lex_env[0] = MMcons(temporary, lex_env[0]);
  371.  
  372. /**/
  373.                 }
  374.             }
  375.         }
  376.     }
  377.  
  378.     narg = arg_top - base;
  379.     if (narg < nreq) {
  380.         if (nopt == 0 && !rest_flag && !key_flag) {
  381.             vs_base = base;
  382.             vs_top = arg_top;
  383.             check_arg_failed(nreq);
  384.         }
  385.         FEtoo_few_arguments(base, arg_top);
  386.     }
  387.     if (!rest_flag && !key_flag && narg > nreq+nopt) {
  388.         if (nopt == 0) {
  389.             vs_base = base;
  390.             vs_top = arg_top;
  391.             check_arg_failed(nreq);
  392.         }
  393.         FEtoo_many_arguments(base, arg_top);
  394.     }
  395.     for (i = 0;  i < nreq;  i++)
  396.         bind_var(required[i].req_var,
  397.              base[i],
  398.              required[i].req_spp);
  399.     for (i = 0;  i < nopt;  i++)
  400.         if (nreq+i < narg) {
  401.             bind_var(optional[i].opt_var,
  402.                  base[nreq+i],
  403.                  optional[i].opt_spp);
  404.             if (optional[i].opt_svar != Cnil)
  405.                 bind_var(optional[i].opt_svar,
  406.                      Ct,
  407.                      optional[i].opt_svar_spp);
  408.         } else {
  409.             eval_assign(temporary, optional[i].opt_init);
  410.             bind_var(optional[i].opt_var,
  411.                  temporary,
  412.                  optional[i].opt_spp);
  413.             if (optional[i].opt_svar != Cnil)
  414.                 bind_var(optional[i].opt_svar,
  415.                      Cnil,
  416.                      optional[i].opt_svar_spp);
  417.         }
  418.     if (rest_flag) {
  419.         vs_push(Cnil);
  420.         for (i = narg, j = nreq+nopt;  --i >= j;  )
  421.             vs_head = make_cons(base[i], vs_head);
  422.         bind_var(rest->rest_var, vs_head, rest->rest_spp);
  423.     }
  424.     if (key_flag) {
  425.         i = narg - nreq - nopt;
  426.         if (i >= 0 && i%2 != 0)
  427.             FEerror("Keyword values are missing.", 0);
  428.         other_keys_appeared = FALSE;
  429.         for (i = nreq + nopt;  i < narg;  i += 2) {
  430.             if (!keywordp(base[i]))
  431.                 FEerror("~S is not a keyword.",
  432.                     1, base[i]);
  433.             if (base[i] == Kallow_other_keys &&
  434.                 base[i+1] != Cnil)
  435.                 allow_other_keys_flag = TRUE;
  436.             for (j = 0;  j < nkey;  j++) {
  437.                 if (keyword[j].key_word == base[i]) {
  438.                     if (keyword[j].key_svar_val
  439.                         != Cnil)
  440.                         goto NEXT_ARG;
  441.                     keyword[j].key_val
  442.                     = base[i+1];
  443.                     keyword[j].key_svar_val
  444.                     = Ct;
  445.                     goto NEXT_ARG;
  446.                 }
  447.             }
  448.             other_keys_appeared = TRUE;
  449.  
  450.         NEXT_ARG:
  451.             continue;
  452.         }
  453.         if (other_keys_appeared && !allow_other_keys_flag)
  454.             FEerror("Other-keys are not allowed.", 0);
  455.     }
  456.     for (i = 0;  i < nkey;  i++)
  457.         if (keyword[i].key_svar_val != Cnil) {
  458.             bind_var(keyword[i].key_var,
  459.                  keyword[i].key_val,
  460.                  keyword[i].key_spp);
  461.             if (keyword[i].key_svar != Cnil)
  462.                 bind_var(keyword[i].key_svar,
  463.                      keyword[i].key_svar_val,
  464.                      keyword[i].key_svar_spp);
  465.         } else {
  466.             eval_assign(temporary, keyword[i].key_init);
  467.             bind_var(keyword[i].key_var,
  468.                  temporary,
  469.                  keyword[i].key_spp);
  470.             if (keyword[i].key_svar != Cnil)
  471.                 bind_var(keyword[i].key_svar,
  472.                      keyword[i].key_svar_val,
  473.                      keyword[i].key_svar_spp);
  474.         }
  475.     for (i = 0;  i < naux;  i++) {
  476.         eval_assign(temporary, aux[i].aux_init);
  477.         bind_var(aux[i].aux_var, temporary, aux[i].aux_spp);
  478.     }
  479.     if (type_of(body) != t_cons || body->c.c_car == form) {
  480.         vs_reset;
  481.         vs_head = body;
  482.     } else {
  483.         body = make_cons(form, body->c.c_cdr);
  484.         vs_reset;
  485.         vs_head = body;
  486.     }
  487.     return;
  488.  
  489. REQUIRED_ONLY:
  490.     vs_push(Cnil);
  491.     for (;  !endp(body);  body = body->c.c_cdr) {
  492.         form = body->c.c_car;
  493.  
  494.         /*  MACRO EXPANSION  */
  495.         vs_head = form = macro_expand(form);
  496.  
  497.         if (type_of(form) == t_string) {
  498.             if (endp(body->c.c_cdr))
  499.                 break;
  500.             continue;
  501.         }
  502.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  503.             break;
  504.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  505.             if (type_of(ds->c.c_car) != t_cons)
  506.                 illegal_declare(form);
  507.             if (ds->c.c_car->c.c_car == Sspecial) {
  508.                 vs = ds->c.c_car->c.c_cdr;
  509.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  510.                     v = vs->c.c_car;
  511.                     check_symbol(v);
  512. /**/
  513.  
  514.     special_processed = FALSE;
  515.     for (i = 0;  i < nreq;  i++)
  516.         if (required[i].req_var == v) {
  517.             required[i].req_spp = Ct;
  518.             special_processed = TRUE;
  519.         }
  520.     if (special_processed)
  521.         continue;
  522.     /*  lex_special_bind(v);  */
  523.     temporary = MMcons(v, Cnil);
  524.     lex_env[0] = MMcons(temporary, lex_env[0]);
  525.  
  526. /**/
  527.                 }
  528.             }
  529.         }
  530.     }
  531.  
  532.     narg = arg_top - base;
  533.     if (narg != nreq) {
  534.         vs_base = base;
  535.         vs_top = arg_top;
  536.         check_arg_failed(nreq);
  537.     }
  538.     for (i = 0;  i < nreq;  i++)
  539.         bind_var(required[i].req_var,
  540.              base[i],
  541.              required[i].req_spp);
  542.     if (type_of(body) != t_cons || body->c.c_car == form) {
  543.         vs_reset;
  544.         vs_head = body;
  545.     } else {
  546.         body = make_cons(form, body->c.c_cdr);
  547.         vs_reset;
  548.         vs_head = body;
  549.     }
  550. }
  551.  
  552. bind_var(var, val, spp)
  553. object var, val, spp;
  554. {
  555.     vs_mark;
  556.  
  557.     switch (var->s.s_stype) {
  558.     case stp_constant:
  559.         FEerror("Cannot bind the constant ~S.", 1, var);
  560.  
  561.     case stp_special:
  562.         bds_bind(var, val);
  563.         break;
  564.  
  565.     default:
  566.         if (spp != Cnil) {
  567.             /*  lex_special_bind(var);  */
  568.             temporary = MMcons(var, Cnil);
  569.             lex_env[0] = MMcons(temporary, lex_env[0]);
  570.             bds_bind(var, val);
  571.         } else {
  572.             /*  lex_local_bind(var, val);  */
  573.             temporary = MMcons(val, Cnil);
  574.             temporary = MMcons(var, temporary);
  575.             lex_env[0] = MMcons(temporary, lex_env[0]);
  576.         }
  577.         break;
  578.     }
  579.     vs_reset;
  580. }
  581.  
  582. illegal_lambda()
  583. {
  584.     FEerror("Illegal lambda expression.", 0);
  585. }
  586.  
  587. /*
  588. struct bind_temp {
  589.     object    bt_var;
  590.     object    bt_spp;
  591.     object    bt_init;
  592.     object    bt_aux;
  593. };
  594. */
  595.  
  596. object
  597. find_special(body, start, end)
  598. object body;
  599. struct bind_temp *start, *end;
  600. {
  601.     object form;
  602.     object ds, vs, v;
  603.     struct bind_temp *bt;
  604.     bool special_processed;
  605.     vs_mark;
  606.  
  607.     vs_push(Cnil);
  608.     for (;  !endp(body);  body = body->c.c_cdr) {
  609.         form = body->c.c_car;
  610.  
  611.         /*  MACRO EXPANSION  */
  612.         form = macro_expand(form);
  613.         vs_head = form;
  614.  
  615.         if (type_of(form) == t_string) {
  616.             if (endp(body->c.c_cdr))
  617.                 break;
  618.             continue;
  619.         }
  620.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  621.             break;
  622.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  623.             if (type_of(ds->c.c_car) != t_cons)
  624.                 illegal_declare(form);
  625.             if (ds->c.c_car->c.c_car == Sspecial) {
  626.                 vs = ds->c.c_car->c.c_cdr;
  627.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  628.                     v = vs->c.c_car;
  629.                     check_symbol(v);
  630. /**/
  631.     special_processed = FALSE;
  632.     for (bt = start;  bt < end;  bt++)
  633.         if (bt->bt_var == v) {
  634.             bt->bt_spp = Ct;
  635.             special_processed = TRUE;
  636.         }
  637.     if (special_processed)
  638.         continue;
  639.     /*  lex_special_bind(v);  */
  640.     temporary = MMcons(v, Cnil);
  641.     lex_env[0] = MMcons(temporary, lex_env[0]);
  642. /**/
  643.                 }
  644.             }
  645.         }
  646.     }
  647.  
  648.     if (body != Cnil && body->c.c_car != form)
  649.         body = make_cons(form, body->c.c_cdr);
  650.     vs_reset;
  651.     return(body);
  652. }
  653.  
  654. object
  655. let_bind(body, start, end)
  656. object body;
  657. struct bind_temp *start, *end;
  658. {
  659.     struct bind_temp *bt;
  660.  
  661.     bds_check;
  662.     vs_push(find_special(body, start, end));
  663.     for (bt = start;  bt < end;  bt++) {
  664.         eval_assign(bt->bt_init, bt->bt_init);
  665.     }
  666.     for (bt = start;  bt < end;  bt++) {
  667.         bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
  668.     }
  669.     return(vs_pop);
  670. }
  671.  
  672. object
  673. letA_bind(body, start, end)
  674. object body;
  675. struct bind_temp *start, *end;
  676. {
  677.     struct bind_temp *bt;
  678.     
  679.     bds_check;
  680.     vs_push(find_special(body, start, end));
  681.     for (bt = start;  bt < end;  bt++) {
  682.         eval_assign(bt->bt_init, bt->bt_init);
  683.         bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
  684.     }
  685.     return(vs_pop);
  686. }
  687.  
  688.  
  689. #ifdef AV
  690. #define    key(i)        ktab[i]
  691. #endif
  692. #ifdef MV
  693.  
  694. #endif
  695.  
  696. #define    NOT_YET        10
  697. #define    FOUND        11
  698. #define    NOT_KEYWORD    1
  699.  
  700. parse_key(base, rest, allow_other_keys, n, first_key)
  701. object *base;
  702. bool rest, allow_other_keys;
  703. register int n;
  704. object first_key;
  705. {
  706.     object *ktab = &first_key;
  707.     object other_key = OBJNULL;
  708.     int narg, error_flag = 0;
  709.     object *v, k, *top;
  710.     register int i;
  711.  
  712.     narg = vs_top - base;
  713.     if (narg <= 0) {
  714.         if (rest) {
  715.             base[0] = Cnil;
  716.             base++;
  717.         }
  718.         top = base + n;
  719.         for (i = 0;  i < n;  i++) {
  720.             base[i] = Cnil;
  721.             top[i] = Cnil;
  722.         }
  723.         return;
  724.     }
  725.     if (narg%2 != 0)
  726.         FEerror("Odd number of arguments for keywords.", 0);
  727.     if (narg == 2) {
  728.         k = base[0];
  729.         if (!keywordp(k))
  730.             FEerror("~S is not a keyword.", 1, k);
  731.         if (k == Kallow_other_keys && base[1] != Cnil)
  732.             allow_other_keys = TRUE;
  733.         temporary = base[1];
  734.         if (rest)
  735.             base++;
  736.         top = base + n;
  737.         other_key = k;
  738.         for (i = 0;  i < n;  i++) {
  739.             if (key(i) == k) {
  740.                 base[i] = temporary;
  741.                 top[i] = Ct;
  742.                 other_key = OBJNULL;
  743.             } else {
  744.                 base[i] = Cnil;
  745.                 top[i] = Cnil;
  746.             }
  747.         }
  748.         if (rest) {
  749.             temporary = make_cons(temporary, Cnil);
  750.             base[-1] = make_cons(k, temporary);
  751.         }
  752.         if (other_key != OBJNULL && !allow_other_keys)
  753.             FEerror("The keyword ~S is not allowed.",1,other_key);
  754.         return;
  755.     }
  756.     for (i = 0;  i < n;  i++) {
  757.         k = key(i);
  758.         k->s.s_stype = NOT_YET;
  759.         k->s.s_dbind = Cnil;
  760.     }
  761.     for (v = base;  v < vs_top;  v += 2) {
  762.         k = v[0];
  763.         if (!keywordp(k)) {
  764.             error_flag = NOT_KEYWORD;
  765.             other_key = k;
  766.             continue;
  767.         }
  768.         if (k->s.s_stype == NOT_YET) {
  769.             k->s.s_dbind = v[1];
  770.             k->s.s_stype = FOUND;
  771.         } else if (k->s.s_stype == FOUND) {
  772.             ;
  773.         } else if (other_key == OBJNULL)
  774.             other_key = k;
  775.         if (k == Kallow_other_keys && v[1] != Cnil)
  776.             allow_other_keys = TRUE;
  777.     }
  778.     if (rest) {
  779.         top = vs_top;
  780.         vs_push(Cnil);
  781.         base++;
  782.         while (base < vs_top)
  783.             stack_cons();
  784.         vs_top = top;
  785.     }
  786.     top = base + n;
  787.     for (i = 0;  i < n;  i++) {
  788.         k = key(i);
  789.         base[i] = k->s.s_dbind;
  790.         top[i] = k->s.s_stype == FOUND ? Ct : Cnil;
  791.         k->s.s_dbind = k;
  792.         k->s.s_stype = (short)stp_constant;
  793.     }
  794.     if (error_flag == NOT_KEYWORD)
  795.         FEerror("~S is not a keyword.", 1, other_key);
  796.     if (other_key != OBJNULL && !allow_other_keys)
  797.         FEerror("The keyword ~S is not allowed.", 1, other_key);
  798. }
  799.  
  800. check_other_key(l, n, first_key)
  801. object l;
  802. int n;
  803. object first_key;
  804. {
  805.     object *ktab = &first_key;
  806.     object other_key = OBJNULL;
  807.     object k;
  808.     int i;
  809.     bool allow_other_keys = FALSE;
  810.  
  811.     for (;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  812.         k = l->c.c_car;
  813.         if (!keywordp(k))
  814.             FEerror("~S is not a keyword.", 1, k);
  815.         if (endp(l->c.c_cdr))
  816.             FEerror("Odd number of arguments for keywords.", 0);
  817.         if (k == Kallow_other_keys && l->c.c_cdr->c.c_car != Cnil) {
  818.             allow_other_keys = TRUE;
  819.         } else {
  820.             for (i = 0;  i < n;  i++)
  821.                 if (key(i) == k) {key(i) = Cnil; break;}
  822.             if (i >= n) other_key = k;
  823.         }
  824.     }
  825.     if (other_key != OBJNULL && !allow_other_keys)
  826.         FEerror("The keyword ~S is not allowed or is duplicated.",
  827.             1, other_key);
  828. }
  829.  
  830. init_bind()
  831. {
  832.     ANDoptional = make_ordinary("&OPTIONAL");
  833.     enter_mark_origin(&ANDoptional);
  834.     ANDrest = make_ordinary("&REST");
  835.     enter_mark_origin(&ANDrest);
  836.     ANDkey = make_ordinary("&KEY");
  837.     enter_mark_origin(&ANDkey);
  838.     ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS");
  839.     enter_mark_origin(&ANDallow_other_keys);
  840.     ANDaux = make_ordinary("&AUX");
  841.     enter_mark_origin(&ANDaux);
  842.  
  843.     make_constant("LAMBDA-LIST-KEYWORDS",
  844.     make_cons(ANDoptional,
  845.     make_cons(ANDrest,
  846.     make_cons(ANDkey,
  847.     make_cons(ANDallow_other_keys,
  848.     make_cons(ANDaux,
  849.     make_cons(make_ordinary("&WHOLE"),
  850.     make_cons(make_ordinary("&ENVIRONMENT"),
  851.     make_cons(make_ordinary("&BODY"), Cnil)))))))));
  852.  
  853.     make_constant("LAMBDA-PARAMETERS-LIMIT",
  854.               make_fixnum(64));
  855.  
  856.     Kallow_other_keys = make_keyword("ALLOW-OTHER-KEYS");
  857.  
  858.     temporary = Cnil;
  859.     enter_mark_origin(&temporary);
  860.  
  861.     three_nils.nil3_self[0] = Cnil;
  862.     three_nils.nil3_self[1] = Cnil;
  863.     three_nils.nil3_self[2] = Cnil;
  864.  
  865.     six_nils.nil6_self[0] = Cnil;
  866.     six_nils.nil6_self[1] = Cnil;
  867.     six_nils.nil6_self[2] = Cnil;
  868.     six_nils.nil6_self[3] = Cnil;
  869.     six_nils.nil6_self[4] = Cnil;
  870.     six_nils.nil6_self[5] = Cnil;
  871. }
  872.